home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Module / Build / Version.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  12.5 KB  |  590 lines
  1. package Module::Build::Version;
  2. use strict;
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = 0.7203;
  6.  
  7. eval "use version $VERSION";
  8. if ($@) { # can't locate version files, use our own
  9.  
  10.     # Avoid redefined warnings if an old version.pm was available
  11.     delete $version::{$_} foreach keys %version::;
  12.  
  13.     # first we get the stub version module
  14.     my $version;
  15.     while (<DATA>) {
  16.     s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
  17.     $version .= $_ if $_;
  18.     last if /^1;$/;
  19.     }
  20.  
  21.     # and now get the current version::vpp code
  22.     my $vpp;
  23.     while (<DATA>) {
  24.     s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
  25.     $vpp .= $_ if $_;
  26.     last if /^1;$/;
  27.     }
  28.  
  29.     # but we eval them in reverse order since version depends on
  30.     # version::vpp to already exist
  31.     eval $vpp; die $@ if $@;
  32.     $INC{'version/vpp.pm'} = 'inside Module::Build::Version';
  33.     eval $version; die $@ if $@;
  34.     $INC{'version.pm'} = 'inside Module::Build::Version';
  35. }
  36.  
  37. # now we can safely subclass version, installed or not
  38. use vars qw(@ISA);
  39. @ISA = qw(version);
  40.  
  41. 1;
  42. __DATA__
  43. # stub version module to make everything else happy
  44. package version;
  45.  
  46. use 5.005_04;
  47. use strict;
  48.  
  49. use vars qw(@ISA $VERSION $CLASS *qv);
  50.  
  51. $VERSION = 0.000;
  52.  
  53. $CLASS = 'version';
  54.  
  55. push @ISA, "version::vpp";
  56. *version::qv = \&version::vpp::qv;
  57.  
  58. # Preloaded methods go here.
  59. sub import {
  60.     my ($class) = @_;
  61.     my $callpkg = caller();
  62.     no strict 'refs';
  63.     
  64.     *{$callpkg."::qv"} = 
  65.         sub {return bless version::qv(shift), $class }
  66.     unless defined(&{"$callpkg\::qv"});
  67.  
  68. }
  69.  
  70. 1;
  71. # replace everything from here to the end with the current version/vpp.pm
  72.  
  73. package version::vpp;
  74. use strict;
  75.  
  76. use locale;
  77. use vars qw ($VERSION @ISA @REGEXS);
  78. $VERSION = 0.7203;
  79.  
  80. push @REGEXS, qr/
  81.     ^v?    # optional leading 'v'
  82.     (\d*)    # major revision not required
  83.     \.    # requires at least one decimal
  84.     (?:(\d+)\.?){1,}
  85.     /x;
  86.  
  87. use overload (
  88.     '""'       => \&stringify,
  89.     '0+'       => \&numify,
  90.     'cmp'      => \&vcmp,
  91.     '<=>'      => \&vcmp,
  92.     'bool'     => \&vbool,
  93.     'nomethod' => \&vnoop,
  94. );
  95.  
  96. sub new
  97. {
  98.     my ($class, $value) = @_;
  99.     my $self = bless ({}, ref ($class) || $class);
  100.     
  101.     if ( ref($value) && eval("$value->isa('version')") ) {
  102.         # Can copy the elements directly
  103.         $self->{version} = [ @{$value->{version} } ];
  104.         $self->{qv} = 1 if $value->{qv};
  105.         $self->{alpha} = 1 if $value->{alpha};
  106.         $self->{original} = ''.$value->{original};
  107.         return $self;
  108.     }
  109.  
  110.     require POSIX;
  111.     my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);
  112.     my $radix_comma = ( POSIX::localeconv()->{decimal_point} eq ',' );
  113.  
  114.     if ( not defined $value or $value =~ /^undef$/ ) {
  115.         # RT #19517 - special case for undef comparison
  116.         # or someone forgot to pass a value
  117.         push @{$self->{version}}, 0;
  118.         $self->{original} = "0";
  119.         return ($self);
  120.     }
  121.  
  122.     if ( $#_ == 2 ) { # must be CVS-style
  123.         $value = 'v'.$_[2];
  124.     }
  125.  
  126.     $value = _un_vstring($value);
  127.  
  128.     # exponential notation
  129.     if ( $value =~ /\d+.?\d*e-?\d+/ ) {
  130.         $value = sprintf("%.9f",$value);
  131.         $value =~ s/(0+)$//;
  132.     }
  133.     
  134.     # if the original locale used commas for decimal points, we
  135.     # just replace commas with decimal places, rather than changing
  136.     # locales
  137.     if ( $radix_comma ) {
  138.         $value =~ tr/,/./;
  139.     }
  140.  
  141.     # This is not very efficient, but it is morally equivalent
  142.     # to the XS code (as that is the reference implementation).
  143.     # See vutil/vutil.c for details
  144.     my $qv = 0;
  145.     my $alpha = 0;
  146.     my $width = 3;
  147.     my $saw_period = 0;
  148.     my ($start, $last, $pos, $s);
  149.     $s = 0;
  150.  
  151.     while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
  152.         $s++;
  153.     }
  154.  
  155.     if (substr($value,$s,1) eq 'v') {
  156.         $s++;    # get past 'v'
  157.         $qv = 1; # force quoted version processing
  158.     }
  159.  
  160.     $start = $last = $pos = $s;
  161.         
  162.     # pre-scan the input string to check for decimals/underbars
  163.     while ( substr($value,$pos,1) =~ /[._\d]/ ) {
  164.         if ( substr($value,$pos,1) eq '.' ) {
  165.         if ($alpha) {
  166.             require Carp;
  167.             Carp::croak("Invalid version format ".
  168.                 "(underscores before decimal)");
  169.         }
  170.         $saw_period++;
  171.         $last = $pos;
  172.         }
  173.         elsif ( substr($value,$pos,1) eq '_' ) {
  174.         if ($alpha) {
  175.             require Carp;
  176.             Carp::croak("Invalid version format ".
  177.                 "(multiple underscores)");
  178.         }
  179.         $alpha = 1;
  180.         $width = $pos - $last - 1; # natural width of sub-version
  181.         }
  182.         $pos++;
  183.     }
  184.  
  185.     if ( $alpha && !$saw_period ) {
  186.         require Carp;
  187.         Carp::croak("Invalid version format (alpha without decimal)");
  188.     }
  189.  
  190.     if ( $alpha && $saw_period && $width == 0 ) {
  191.         require Carp;
  192.         Carp::croak("Invalid version format (misplaced _ in number)");
  193.     }
  194.  
  195.     if ( $saw_period > 1 ) {
  196.         $qv = 1; # force quoted version processing
  197.     }
  198.  
  199.     $pos = $s;
  200.  
  201.     if ( $qv ) {
  202.         $self->{qv} = 1;
  203.     }
  204.  
  205.     if ( $alpha ) {
  206.         $self->{alpha} = 1;
  207.     }
  208.  
  209.     if ( !$qv && $width < 3 ) {
  210.         $self->{width} = $width;
  211.     }
  212.  
  213.     while ( substr($value,$pos,1) =~ /\d/ ) {
  214.         $pos++;
  215.     }
  216.  
  217.     if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
  218.         my $rev;
  219.  
  220.         while (1) {
  221.         $rev = 0;
  222.         {
  223.  
  224.             # this is atoi() that delimits on underscores
  225.             my $end = $pos;
  226.             my $mult = 1;
  227.             my $orev;
  228.  
  229.             # the following if() will only be true after the decimal
  230.             # point of a version originally created with a bare
  231.             # floating point number, i.e. not quoted in any way
  232.             if ( !$qv && $s > $start && $saw_period == 1 ) {
  233.             $mult *= 100;
  234.             while ( $s < $end ) {
  235.                 $orev = $rev;
  236.                 $rev += substr($value,$s,1) * $mult;
  237.                 $mult /= 10;
  238.                 if ( abs($orev) > abs($rev) ) {
  239.                 require Carp;
  240.                 Carp::croak("Integer overflow in version");
  241.                 }
  242.                 $s++;
  243.                 if ( substr($value,$s,1) eq '_' ) {
  244.                 $s++;
  245.                 }
  246.             }
  247.             }
  248.             else {
  249.             while (--$end >= $s) {
  250.                 $orev = $rev;
  251.                 $rev += substr($value,$end,1) * $mult;
  252.                 $mult *= 10;
  253.                 if ( abs($orev) > abs($rev) ) {
  254.                 require Carp;
  255.                 Carp::croak("Integer overflow in version");
  256.                 }
  257.             }
  258.             }
  259.         }
  260.  
  261.         # Append revision
  262.         push @{$self->{version}}, $rev;
  263.         if ( substr($value,$pos,1) eq '.' 
  264.             && substr($value,$pos+1,1) =~ /\d/ ) {
  265.             $s = ++$pos;
  266.         }
  267.         elsif ( substr($value,$pos,1) eq '_' 
  268.             && substr($value,$pos+1,1) =~ /\d/ ) {
  269.             $s = ++$pos;
  270.         }
  271.         elsif ( substr($value,$pos,1) =~ /\d/ ) {
  272.             $s = $pos;
  273.         }
  274.         else {
  275.             $s = $pos;
  276.             last;
  277.         }
  278.         if ( $qv ) {
  279.             while ( substr($value,$pos,1) =~ /\d/ ) {
  280.             $pos++;
  281.             }
  282.         }
  283.         else {
  284.             my $digits = 0;
  285.             while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
  286.             if ( substr($value,$pos,1) ne '_' ) {
  287.                 $digits++;
  288.             }
  289.             $pos++;
  290.             }
  291.         }
  292.         }
  293.     }
  294.     if ( $qv ) { # quoted versions always get at least three terms
  295.         my $len = scalar @{$self->{version}};
  296.         $len = 3 - $len;
  297.         while ($len-- > 0) {
  298.         push @{$self->{version}}, 0;
  299.         }
  300.     }
  301.  
  302.     if ( substr($value,$pos) ) { # any remaining text
  303.         warn "Version string '$value' contains invalid data; ".
  304.              "ignoring: '".substr($value,$pos)."'";
  305.     }
  306.  
  307.     # cache the original value for use when stringification
  308.     $self->{original} = substr($value,0,$pos);
  309.  
  310.     return ($self);
  311. }
  312.  
  313. sub numify 
  314. {
  315.     my ($self) = @_;
  316.     unless (_verify($self)) {
  317.     require Carp;
  318.     Carp::croak("Invalid version object");
  319.     }
  320.     my $width = $self->{width} || 3;
  321.     my $alpha = $self->{alpha} || "";
  322.     my $len = $#{$self->{version}};
  323.     my $digit = $self->{version}[0];
  324.     my $string = sprintf("%d.", $digit );
  325.  
  326.     for ( my $i = 1 ; $i < $len ; $i++ ) {
  327.     $digit = $self->{version}[$i];
  328.     if ( $width < 3 ) {
  329.         my $denom = 10**(3-$width);
  330.         my $quot = int($digit/$denom);
  331.         my $rem = $digit - ($quot * $denom);
  332.         $string .= sprintf("%0".$width."d_%d", $quot, $rem);
  333.     }
  334.     else {
  335.         $string .= sprintf("%03d", $digit);
  336.     }
  337.     }
  338.  
  339.     if ( $len > 0 ) {
  340.     $digit = $self->{version}[$len];
  341.     if ( $alpha && $width == 3 ) {
  342.         $string .= "_";
  343.     }
  344.     $string .= sprintf("%0".$width."d", $digit);
  345.     }
  346.     else # $len = 0
  347.     {
  348.     $string .= sprintf("000");
  349.     }
  350.  
  351.     return $string;
  352. }
  353.  
  354. sub normal 
  355. {
  356.     my ($self) = @_;
  357.     unless (_verify($self)) {
  358.     require Carp;
  359.     Carp::croak("Invalid version object");
  360.     }
  361.     my $alpha = $self->{alpha} || "";
  362.     my $len = $#{$self->{version}};
  363.     my $digit = $self->{version}[0];
  364.     my $string = sprintf("v%d", $digit );
  365.  
  366.     for ( my $i = 1 ; $i < $len ; $i++ ) {
  367.     $digit = $self->{version}[$i];
  368.     $string .= sprintf(".%d", $digit);
  369.     }
  370.  
  371.     if ( $len > 0 ) {
  372.     $digit = $self->{version}[$len];
  373.     if ( $alpha ) {
  374.         $string .= sprintf("_%0d", $digit);
  375.     }
  376.     else {
  377.         $string .= sprintf(".%0d", $digit);
  378.     }
  379.     }
  380.  
  381.     if ( $len <= 2 ) {
  382.     for ( $len = 2 - $len; $len != 0; $len-- ) {
  383.         $string .= sprintf(".%0d", 0);
  384.     }
  385.     }
  386.  
  387.     return $string;
  388. }
  389.  
  390. sub stringify
  391. {
  392.     my ($self) = @_;
  393.     unless (_verify($self)) {
  394.     require Carp;
  395.     Carp::croak("Invalid version object");
  396.     }
  397.     return $self->{original};
  398. }
  399.  
  400. sub vcmp
  401. {
  402.     require UNIVERSAL;
  403.     my ($left,$right,$swap) = @_;
  404.     my $class = ref($left);
  405.     unless ( UNIVERSAL::isa($right, $class) ) {
  406.     $right = $class->new($right);
  407.     }
  408.  
  409.     if ( $swap ) {
  410.     ($left, $right) = ($right, $left);
  411.     }
  412.     unless (_verify($left)) {
  413.     require Carp;
  414.     Carp::croak("Invalid version object");
  415.     }
  416.     unless (_verify($right)) {
  417.     require Carp;
  418.     Carp::croak("Invalid version object");
  419.     }
  420.     my $l = $#{$left->{version}};
  421.     my $r = $#{$right->{version}};
  422.     my $m = $l < $r ? $l : $r;
  423.     my $lalpha = $left->is_alpha;
  424.     my $ralpha = $right->is_alpha;
  425.     my $retval = 0;
  426.     my $i = 0;
  427.     while ( $i <= $m && $retval == 0 ) {
  428.     $retval = $left->{version}[$i] <=> $right->{version}[$i];
  429.     $i++;
  430.     }
  431.  
  432.     # tiebreaker for alpha with identical terms
  433.     if ( $retval == 0 
  434.     && $l == $r 
  435.     && $left->{version}[$m] == $right->{version}[$m]
  436.     && ( $lalpha || $ralpha ) ) {
  437.  
  438.     if ( $lalpha && !$ralpha ) {
  439.         $retval = -1;
  440.     }
  441.     elsif ( $ralpha && !$lalpha) {
  442.         $retval = +1;
  443.     }
  444.     }
  445.  
  446.     # possible match except for trailing 0's
  447.     if ( $retval == 0 && $l != $r ) {
  448.     if ( $l < $r ) {
  449.         while ( $i <= $r && $retval == 0 ) {
  450.         if ( $right->{version}[$i] != 0 ) {
  451.             $retval = -1; # not a match after all
  452.         }
  453.         $i++;
  454.         }
  455.     }
  456.     else {
  457.         while ( $i <= $l && $retval == 0 ) {
  458.         if ( $left->{version}[$i] != 0 ) {
  459.             $retval = +1; # not a match after all
  460.         }
  461.         $i++;
  462.         }
  463.     }
  464.     }
  465.  
  466.     return $retval;  
  467. }
  468.  
  469. sub vbool {
  470.     my ($self) = @_;
  471.     return vcmp($self,$self->new("0"),1);
  472. }
  473.  
  474. sub vnoop { 
  475.     require Carp; 
  476.     Carp::croak("operation not supported with version object");
  477. }
  478.  
  479. sub is_alpha {
  480.     my ($self) = @_;
  481.     return (exists $self->{alpha});
  482. }
  483.  
  484. sub qv {
  485.     my ($value) = @_;
  486.  
  487.     $value = _un_vstring($value);
  488.     $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
  489.     my $version = version->new($value); # always use base class
  490.     return $version;
  491. }
  492.  
  493. sub is_qv {
  494.     my ($self) = @_;
  495.     return (exists $self->{qv});
  496. }
  497.  
  498.  
  499. sub _verify {
  500.     my ($self) = @_;
  501.     if ( ref($self)
  502.     && eval { exists $self->{version} }
  503.     && ref($self->{version}) eq 'ARRAY'
  504.     ) {
  505.     return 1;
  506.     }
  507.     else {
  508.     return 0;
  509.     }
  510. }
  511.  
  512. sub _un_vstring {
  513.     my $value = shift;
  514.     # may be a v-string
  515.     if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
  516.     my $tvalue = sprintf("v%vd",$value);
  517.     if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) {
  518.         # must be a v-string
  519.         $value = $tvalue;
  520.     }
  521.     }
  522.     return $value;
  523. }
  524.  
  525. # Thanks to Yitzchak Scott-Thoennes for this mode of operation
  526. {
  527.     local $^W;
  528.     *UNIVERSAL::VERSION = sub {
  529.     my ($obj, $req) = @_;
  530.     my $class = ref($obj) || $obj;
  531.  
  532.     no strict 'refs';
  533.     eval "require $class" unless %{"$class\::"}; # already existing
  534.     return undef if $@ =~ /Can't locate/ and not defined $req;
  535.     
  536.     if ( not %{"$class\::"} and $] >= 5.008) { # file but no package
  537.         require Carp;
  538.         Carp::croak( "$class defines neither package nor VERSION"
  539.         ."--version check failed");
  540.     }
  541.     
  542.     my $version = eval "\$$class\::VERSION";
  543.     if ( defined $version ) {
  544.         local $^W if $] <= 5.008;
  545.         $version = version::vpp->new($version);
  546.     }
  547.  
  548.     if ( defined $req ) {
  549.         unless ( defined $version ) {
  550.         require Carp;
  551.         my $msg =  $] < 5.006 
  552.         ? "$class version $req required--this is only version "
  553.         : "$class does not define \$$class\::VERSION"
  554.           ."--version check failed";
  555.  
  556.         if ( $ENV{VERSION_DEBUG} ) {
  557.             Carp::confess($msg);
  558.         }
  559.         else {
  560.             Carp::croak($msg);
  561.         }
  562.         }
  563.  
  564.         $req = version::vpp->new($req);
  565.  
  566.         if ( $req > $version ) {
  567.         require Carp;
  568.         if ( $req->is_qv ) {
  569.             Carp::croak( 
  570.             sprintf ("%s version %s required--".
  571.                 "this is only version %s", $class,
  572.                 $req->normal, $version->normal)
  573.             );
  574.         }
  575.         else {
  576.             Carp::croak( 
  577.             sprintf ("%s version %s required--".
  578.                 "this is only version %s", $class,
  579.                 $req->stringify, $version->stringify)
  580.             );
  581.         }
  582.         }
  583.     }
  584.  
  585.     return defined $version ? $version->stringify : undef;
  586.     };
  587. }
  588.  
  589. 1; #this line is important and will help the module return a true value
  590.